home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p1 / Runtime (.c & .h) / gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-26  |  20.7 KB  |  629 lines  |  [TEXT/KAHL]
  1. /* Garbage collection */
  2.  
  3. #include "params.h"
  4. #include "gambit.h"
  5. #include "struct.h"
  6. #include "os.h"
  7. #include "opcodes.h"
  8. #include "run.h"
  9.  
  10.  
  11. /*---------------------------------------------------------------------------*/
  12.  
  13.  
  14. void gc_flip();
  15. void gc_scan_range();
  16.  
  17.  
  18. long gc_report; /* index of '##gc-report' variable */
  19.  
  20.  
  21. #ifdef DEBUG_GC
  22. SCM_obj scanned_object;
  23. void show_state();
  24. #endif
  25.  
  26.  
  27. void gc()
  28. { char *nb, *nt;     /* new space bottom and top  */
  29.   SCM_obj *fb, *ft;  /* free space bottom and top */
  30.   long cpu_times1[2], cpu_times2[2];
  31.  
  32.   os_cpu_times( cpu_times1 );
  33.  
  34.   os_notify_gc_begin( SCM_obj_to_int(pstate->id),
  35.                       (long)(sstate->globals[gc_report].value != (long)SCM_false) );
  36.  
  37.   if (pstate->heap_old > pstate->heap_bot)
  38.   { pstate->heap_old = pstate->heap_bot;
  39.     nb = pstate->heap_mid;
  40.     nt = pstate->heap_top;
  41.   }
  42.   else
  43.   { pstate->heap_old = pstate->heap_mid;
  44.     nb = pstate->heap_bot;
  45.     nt = pstate->heap_mid;
  46.   }
  47.  
  48.   gc_flip( (char *)sstate, sstate->const_top, nb, nt, &fb, &ft );
  49.  
  50.   pstate->heap_lim = ((char *)fb) + pstate->heap_margin + (HEAP_ALLOCATION_FUDGE)*sizeof(SCM_obj);
  51.   pstate->heap_ptr = (char *)ft;
  52.  
  53.   pstate->closure_lim = (char *)ft;
  54.   pstate->closure_ptr = (char *)ft;
  55.  
  56.   os_notify_gc_end( SCM_obj_to_int(pstate->id), pstate->heap_mid, pstate->heap_bot, (char *)fb, (char *)ft,
  57.                     (long)(sstate->globals[gc_report].value != (long)SCM_false) );
  58.  
  59.   os_cpu_times( cpu_times2 );
  60.  
  61.   pstate->stats_counters[STAT_GC] += (cpu_times2[0] - cpu_times1[0]) +
  62.                                      (cpu_times2[1] - cpu_times1[1]);
  63. }
  64.  
  65.  
  66. /*---------------------------------------------------------------------------*/
  67.  
  68.  
  69. #define gc_scan_closure(ptr,header) \
  70.   gc_scan_range((SCM_obj *)ptr, SCM_closure_slots(header), (long)sizeof(SCM_obj))
  71.  
  72.  
  73. void gc_scan_roots()
  74. { long i, g, n, m;
  75.   char *ptr, *limit;
  76.  
  77.   /* scan processor local storage (each processor has its own) */
  78.  
  79. #ifdef DEBUG_GC
  80.   scanned_object = 0;
  81.   if (sstate->debug)
  82.   { show_state();
  83.     os_warn( "[%d: SCANNING processor local storage]\n", SCM_obj_to_int(pstate->id) );
  84.   }
  85. #endif
  86.  
  87.   gc_scan_range( (SCM_obj *)pstate->processor_storage,
  88.                  (long)(sizeof(pstate->processor_storage) / sizeof(SCM_obj)),
  89.                  (long)sizeof(SCM_obj) );
  90.  
  91.   /* scan global vars (distribute work among processors) */
  92.  
  93. #ifdef DEBUG_GC
  94.   if (sstate->debug)
  95.   { show_state();
  96.     os_warn( "[%d: SCANNING global variables]\n", SCM_obj_to_int(pstate->id) );
  97.   }
  98. #endif
  99.  
  100.   g = SCM_obj_to_int( sstate->globals[GLOBAL_VAR_COUNT].value );
  101.   n = SCM_obj_to_int(pstate->nb_processors);
  102.   m = g/n;
  103.   if (SCM_obj_to_int(pstate->id) < (g%n)) m++;
  104.   gc_scan_range( (SCM_obj *)&sstate->globals[SCM_obj_to_int(pstate->id)].value, m, n*sizeof(struct global_rec) );
  105.  
  106.   for (i=0; i<m; i++)
  107.     sstate->globals[SCM_obj_to_int(pstate->id)+i*n].jump_adr =
  108.       (long)&sstate->tramps[SCM_obj_to_int(pstate->id)+i*n];
  109.  
  110.   /* scan stack (each processor has an independent stack) */
  111.  
  112. #ifdef DEBUG_GC
  113.   if (sstate->debug)
  114.   { show_state();
  115.     os_warn( "[%d: SCANNING stack]\n", SCM_obj_to_int(pstate->id) );
  116.   }
  117. #endif
  118.  
  119.   gc_scan_range( (SCM_obj *)pstate->stack_ptr,
  120.                  (long)(pstate->ltq_head[-1] - pstate->stack_ptr),
  121.                  (long)sizeof(SCM_obj) );
  122.  
  123.   /* scan work queue (each processor has its own) */
  124.  
  125. #ifdef DEBUG_GC 
  126.   if (sstate->debug)
  127.     os_warn( "[%d: SCANNING work queue]\n", SCM_obj_to_int(pstate->id) );
  128. #endif
  129.  
  130.   gc_scan_range( (SCM_obj *)&pstate->workq_head, 1L, (long)sizeof(SCM_obj) );
  131.   gc_scan_range( (SCM_obj *)&pstate->workq_tail, 1L, (long)sizeof(SCM_obj) );
  132.  
  133.   /* scan current task (each processor has its own) */
  134.  
  135. #ifdef DEBUG_GC
  136.   if (sstate->debug)
  137.   { show_state();
  138.     os_warn( "[%d: SCANNING current task]\n", SCM_obj_to_int(pstate->id) );
  139.   }
  140. #endif
  141.  
  142.   gc_scan_range( (SCM_obj *)&pstate->current_task, 1L, (long)sizeof(SCM_obj) );
  143.   gc_scan_range( (SCM_obj *)&pstate->parent_ret, 1L, (long)sizeof(SCM_obj) );
  144.   gc_scan_range( (SCM_obj *)&pstate->parent_frame, 1L, (long)sizeof(SCM_obj) );
  145.   gc_scan_range( (SCM_obj *)&pstate->current_dyn_env, 1L, (long)sizeof(SCM_obj) );
  146.   gc_scan_range( (SCM_obj *)&pstate->temp_task, 1L, (long)sizeof(SCM_obj) );
  147.   gc_scan_range( (SCM_obj *)&pstate->response, 1L, (long)sizeof(SCM_obj) );
  148.  
  149.   /* scan constant space (each processor GCs its own copy) */
  150.  
  151. #ifdef DEBUG_GC
  152.   if (sstate->debug)
  153.   { show_state();
  154.     os_warn( "[%d: SCANNING constant space (with headers)]\n", SCM_obj_to_int(pstate->id) );
  155.   }
  156. #endif
  157.  
  158.   ptr = sstate->const_bot;
  159.   limit = sstate->const_bptr;
  160.  
  161.   while (ptr < limit)
  162.   { long len, header = *(long *)ptr;
  163.  
  164.     ptr += sizeof(long);
  165.  
  166.     if (SCM_header_procedure(header))
  167.     { len = SCM_procedure_length( header );
  168. #ifdef DEBUG_GC
  169.       scanned_object = (long)ptr - sizeof(SCM_obj) + SCM_type_PROCEDURE;
  170. #endif
  171.       if (SCM_header_closure(header))
  172.         gc_scan_closure(ptr,header);
  173.       else
  174.       { long *p, nb_cst;
  175.         p = (long *)(ptr + len);
  176.         nb_cst = SCM_obj_to_int( *(--p) ) - 1;
  177.         gc_scan_range( (SCM_obj *)(p-nb_cst), nb_cst, (long)sizeof(SCM_obj) );
  178.       }
  179.     }
  180.     else
  181.     { len = SCM_header_length( header );
  182. #ifdef DEBUG_GC
  183.       scanned_object = (long)ptr - sizeof(SCM_obj) + SCM_type_SUBTYPED;
  184. #endif
  185.       if (SCM_subtype_is_ovector(SCM_header_subtype( header )))
  186.         gc_scan_range((SCM_obj *)ptr, SCM_header_slots(header), (long)sizeof(SCM_obj));
  187.     }
  188.  
  189.     ptr = (char *)SCM_align(ptr+len);
  190.   }
  191.  
  192. #ifdef DEBUG_GC
  193.   scanned_object = 0;
  194.   if (sstate->debug)
  195.   { show_state();
  196.     os_warn( "[%d: SCANNING constant space (no headers)]\n", SCM_obj_to_int(pstate->id) );
  197.   }
  198. #endif
  199.  
  200.   gc_scan_range( (SCM_obj *)sstate->const_tptr,
  201.                  (long)((SCM_obj *)sstate->const_top - (SCM_obj *)sstate->const_tptr),
  202.                  (long)sizeof(SCM_obj));
  203. }
  204.  
  205.  
  206. /*===========================================================================*/
  207. /*                   Machine independent code follows                        */
  208. /*===========================================================================*/
  209.  
  210.  
  211. /*-----------------------------------------------------------------------------
  212.  *
  213.  * Garbage collector for Gambit
  214.  *
  215.  * Note: this garbage collector assumes that objects are represented
  216.  *       as specified in the document "gambit/doc/repr".
  217.  *
  218.  */
  219.  
  220.  
  221. /*
  222.  
  223. Layout of memory during a GC:
  224.  
  225. (note that the location of old space and new space reverses at every GC)
  226.  
  227.  
  228.                            HEAP
  229. Low addresses
  230.                  _________________________
  231.              /  |                         |
  232.             /   |                         |
  233.             |   |                         |
  234.             |   |                         |
  235.             |   |     ACTIVE OBJECTS      |
  236.             |   |                         |
  237.   OLD SPACE |   |           +             |
  238.             |   |                         |
  239.             |   |        GARBAGE          |
  240.             |   |                         |
  241.             |   |                         |
  242.             \   |                         |
  243.              \  |_________________________|
  244.              /  |. . . . . . . . . . . . .|
  245.             /   |. subtyped & procedures .|
  246.             |   |. . .  & weak pairs . . .|
  247.             |   |. .  (with headers) . . .| <---- bot_scan     |
  248.             |   |. . . . . . . . . . . . .|                    |
  249.             |   |_ _ _ _ _ _ _ _ _ _ _ _ _|                    |
  250.             |   |                         | <---- bot_alloc   \|/
  251.             |   |                         |
  252.   NEW SPACE |   |         FREE MEM        |
  253.             |   |                         |
  254.             |   |_ _ _ _ _ _ _ _ _ _ _ _ _|
  255.             |   |. . . . . . . . . . . . .| <---- top_alloc   /|\
  256.             |   |.  pairs & placeholders .| <---- top_scan     |
  257.             |   |. . . (no headers)  . . .|                    |
  258.             \   |. . . . . . . . . . . . .|                    |
  259.              \  |_________________________|                    |
  260.  
  261. High addresses
  262.  
  263. */
  264.  
  265.  
  266. long const_bot, const_top;                     /* Limits of constant space   */
  267. SCM_obj *bot_alloc, *top_alloc;                /* Allocation pointers        */
  268. SCM_obj *weak_pairs;                           /* Chain of weak pairs        */
  269.  
  270.  
  271. #ifdef DEBUG_GC
  272.  
  273. void show_state()
  274. { os_warn( "[%d: ", SCM_obj_to_int(pstate->id) );
  275.   os_warn( "bot_alloc=0x%x, ", (long)bot_alloc );
  276.   os_warn( "top_alloc=0x%x]\n", (long)top_alloc );
  277. }
  278.  
  279. void show_object( object, from )
  280. SCM_obj object, *from;
  281. { SCM_obj *adr = (object != 0) ? SCM_object_adr(object) : from-10;
  282.   int i;
  283.   for (i=0; i<20; i++)
  284.   { os_warn( "0x%x = ", (long)(adr+i) );
  285.     os_warn( "0x%x\n", adr[i] );
  286.   }
  287. }
  288.  
  289. void show_invalid( value, object, from )
  290. SCM_obj value, object, *from;
  291. { os_warn( "\nGC ERROR: object 0x%x ", (long)object );
  292.   os_warn( "at 0x%x ", (long)from );
  293.   os_warn( "contains invalid value 0x%x\n", (long)value );
  294.   show_object( object, 0L );
  295.   os_quit();
  296. }
  297.  
  298. int correct_value( value )
  299. SCM_obj value;
  300. { if ((SCM_type(value)!=SCM_type_FIXNUM)&&(SCM_type(value)!=SCM_type_SPECIAL))
  301.     if ((((long)value) < const_bot) || (((long)value) >= const_top))
  302.     { int i;
  303.       for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  304.         if ((value >= (long)pstate->ps[i]->heap_bot) &&
  305.             (value <= (long)pstate->ps[i]->heap_top)) return 1;
  306.       return 0;
  307.     }
  308.   return 1;
  309. }
  310.  
  311. #define CHECK_VALID(value,object,from) { if (!correct_value( value )) show_invalid( value, object, from ); }
  312.  
  313. #else
  314.  
  315. #define CHECK_VALID(value,object,from)
  316.  
  317. #endif
  318.  
  319.  
  320. /*-----------------------------------------------------------------------------
  321.  *
  322.  * Scan a range of memory for garbage-collectable objects.  Referenced
  323.  * objects are copied from OLD space to NEW space.
  324.  *
  325.  */
  326.  
  327.  
  328. #define FORWARD_NO_HEADER FORWARD(SCM_copied_no_header(slot0),adr[1])
  329. #define FORWARD_HEADER    FORWARD(SCM_copied_header(slot0),slot0)
  330. #define FORWARD_CLOSURE   FORWARD(!SCM_header_closure(slot0),slot0)
  331. #define FORWARD(copied,forw_ptr)                                      \
  332. adr = SCM_object_adr(object);          /* Get address of object    */ \
  333. read_and_lock(adr, slot0);             /* Lock it and get slot 0   */ \
  334. if (copied)                            /* Has it been copied?      */ \
  335. { *from = forw_ptr;                    /* Update reference         */ \
  336.   CHECK_VALID( forw_ptr, scanned_object, from );                      \
  337.   unlock(adr, slot0);                  /* and unlock object        */ \
  338. }                                                                     \
  339. else
  340.  
  341.  
  342. void gc_scan_range( from, count, step )
  343. SCM_obj *from;                   /* Where to start scanning                  */
  344. long count;                      /* Number of objects to scan                */
  345. long step;                       /* Step between objects (in bytes)          */
  346. { register SCM_obj object;               /* Object being checked             */
  347.   register SCM_obj object_copy;          /* Object after data copied         */
  348.   register SCM_obj *adr;                 /* Pointer to data if mem alloc obj */
  349.   register long slot0;                   /* First slot of that data          */
  350.   register SCM_obj len;                  /* Length of headed object          */
  351.   register SCM_obj *b_alloc = bot_alloc; /* Local copy of bot_alloc          */
  352.   register SCM_obj *t_alloc = top_alloc; /* Local copy of top_alloc          */
  353.  
  354.   while (count-- > 0)                            /* Scan every object        */
  355.   { object = *from;                              /* Fetch next object        */
  356. Rescan:
  357.     if ((((long)object) <  const_bot) ||         /* Don't process objects    */
  358.         (((long)object) >= const_top))           /* stored in constant space */
  359.     {
  360. #ifdef DEBUG_GC
  361.       if (!correct_value( object ))
  362.       { os_warn( "\nGC ERROR: found invalid value 0x%x ", (long)object );
  363.         os_warn( "at 0x%x while scanning\n", (long)from );
  364.         show_object( 0L, from );
  365.         os_quit();
  366.       }
  367. #endif
  368.       switch SCM_type(object)                    /* Dispatch on type         */
  369.       { case SCM_type_PAIR:
  370.           FORWARD_NO_HEADER
  371.           { CHECK_VALID( adr[1], object, from );
  372.             CHECK_VALID( slot0, object, from );
  373.             *(--t_alloc) = adr[1];               /* Allocate and copy pair   */
  374.             *(--t_alloc) = slot0;
  375.             object_copy = SCM_add_type(t_alloc, SCM_type_PAIR);
  376.             adr[1] = object_copy;                /* Remember where copied    */
  377.             store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
  378.             *from = object_copy;                 /* Update reference         */
  379.             CHECK_VALID( object_copy, scanned_object, from );
  380.           }
  381.           break;
  382.  
  383.         case SCM_type_PROCEDURE:                 /* Must be closure          */
  384.           FORWARD_CLOSURE
  385.           { object_copy = SCM_add_type(b_alloc, SCM_type_PROCEDURE);
  386.             *(b_alloc++) = slot0;
  387.             store_and_unlock(adr, object_copy);  /* remember where copied    */
  388.             len = SCM_procedure_length(slot0);
  389.             adr++;
  390.             while (len>0)
  391.             { CHECK_VALID( *adr, object, from );
  392.               *(b_alloc++) = *(adr++);
  393.               len -= sizeof(SCM_obj);
  394.             }
  395.             b_alloc = (SCM_obj *)SCM_align(b_alloc);
  396.             *from = object_copy;                 /* update reference         */
  397.             CHECK_VALID( object_copy, scanned_object, from );
  398.           }
  399.           break;
  400.  
  401.         case SCM_type_SUBTYPED:
  402.           FORWARD_HEADER
  403.           { object_copy = SCM_add_type(b_alloc, SCM_type_SUBTYPED);
  404.             *(b_alloc++) = slot0;
  405.             store_and_unlock(adr, object_copy);  /* remember where copied    */
  406.             len = SCM_header_length(slot0);
  407.             adr++;
  408. #ifdef DEBUG_GC
  409.             if (SCM_subtype_is_ovector(SCM_header_subtype( slot0 )))
  410.               while (len>0)
  411.               { CHECK_VALID( *adr, object, from );
  412.                 *(b_alloc++) = *(adr++);
  413.                 len -= sizeof(SCM_obj);
  414.               }
  415.             else
  416. #endif
  417.               while (len>0)
  418.               { *(b_alloc++) = *(adr++); len -= sizeof(SCM_obj); }
  419.             b_alloc = (SCM_obj *)SCM_align(b_alloc);
  420.             *from = object_copy;                 /* update reference         */
  421.             CHECK_VALID( object_copy, scanned_object, from );
  422.           }
  423.           break;
  424.  
  425.         case SCM_type_PLACEHOLDER:
  426.           /* Assumption: slot 0 is the value slot, and is itself
  427.              if not yet determined */
  428.           FORWARD_NO_HEADER
  429.           { if (slot0 != object)                 /* Determined?              */
  430.             { unlock(adr, slot0);                /* Unlock & restore value   */
  431.               object = slot0;                    /* Rescan value             */
  432.               *from = object;                    /* Replace P.H. by value    */
  433.               CHECK_VALID( object, scanned_object, from );
  434.               goto Rescan;
  435.             }
  436.             CHECK_VALID( adr[3], object, from );
  437.             CHECK_VALID( adr[2], object, from );
  438.             CHECK_VALID( adr[1], object, from );
  439.             CHECK_VALID( slot0, object, from );
  440.             *(--t_alloc) = adr[3];
  441.             *(--t_alloc) = adr[2];
  442.             *(--t_alloc) = adr[1];
  443.             *(--t_alloc) = slot0;
  444.             object_copy = SCM_add_type(t_alloc, SCM_type_PLACEHOLDER);
  445.             adr[1] = object_copy;                /* Remember where copied    */
  446.             store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
  447.             *from = object_copy;                 /* Update reference         */
  448.             CHECK_VALID( object_copy, scanned_object, from );
  449.           }
  450.           break;
  451.  
  452.         case SCM_type_WEAK_PAIR:
  453.           FORWARD_NO_HEADER
  454.           { CHECK_VALID( adr[1], object, from );
  455.             CHECK_VALID( slot0, object, from );
  456.             *(b_alloc++) = SCM_make_header(3*sizeof(SCM_obj),SCM_subtype_WEAK_PAIR);
  457.             *(b_alloc++) = (SCM_obj)weak_pairs;
  458.             weak_pairs = b_alloc;
  459.             object_copy = SCM_add_type(b_alloc, SCM_type_WEAK_PAIR);
  460.             *(b_alloc++) = slot0;                /* Allocate and copy pair   */
  461.             *(b_alloc++) = adr[1];
  462.             adr[1] = object_copy;                /* Remember where copied    */
  463.             store_and_unlock(adr, (long)SCM_BH); /* Mark as copied & unlock  */
  464.             *from = object_copy;                 /* Update reference         */
  465.             CHECK_VALID( object_copy, scanned_object, from );
  466.           }
  467.           break;
  468.  
  469.         case SCM_type_FIXNUM:
  470.         case SCM_type_SPECIAL: break;
  471.  
  472.         default:
  473.           os_warn( "\nGC ERROR: Bad type code, object=0x%x", (long)object );
  474. #ifdef DEBUG_GC
  475.           if (scanned_object != 0) os_warn( " in 0x%x", scanned_object );
  476. #endif
  477.           os_warn( " at 0x%x\n", (long)from );
  478. #ifdef DEBUG_GC
  479.           show_object( scanned_object, from );
  480. #endif
  481.           os_quit();
  482.       }
  483.     }
  484.     from = (SCM_obj *)(((char *)from) + step);  /* Move to next object       */
  485.   }
  486.  
  487.   bot_alloc = b_alloc;                          /* Put copies back           */
  488.   top_alloc = t_alloc;
  489. }
  490.  
  491.  
  492. /*-----------------------------------------------------------------------------
  493.  *
  494.  * Main procedure of the garbage collector.
  495.  *
  496.  */
  497.  
  498. void gc_flip( const_b, const_t, new_b, new_t, free_b, free_t )
  499. char *const_b, *const_t;                /* Location of constant space        */
  500. char *new_b, *new_t;                    /* Location of new space             */
  501. SCM_obj **free_b, **free_t;             /* Location of free space after GC   */
  502. { SCM_obj *top_scan, *bot_scan;         /* Pointers to scan copied data      */
  503.  
  504.   const_bot  = (long)const_b;
  505.   const_top  = (long)const_t;
  506.  
  507.   bot_alloc = (SCM_obj *)new_b;
  508.   top_alloc = (SCM_obj *)new_t;
  509.  
  510.   bot_scan  = bot_alloc;
  511.   top_scan  = top_alloc;
  512.  
  513.   weak_pairs = NULL;
  514.  
  515. #ifdef DEBUG_GC
  516.   if (sstate->debug)
  517.   { os_warn( "[%d: ", SCM_obj_to_int(pstate->id) );
  518.     os_warn( "constant space = 0x%x..", (long)sstate->const_bot );
  519.     os_warn( "0x%x ", (long)sstate->const_bptr );
  520.     os_warn( "0x%x..", (long)sstate->const_tptr );
  521.    os_warn( "0x%x]\n", (long)sstate->const_top );
  522.   }
  523. #endif
  524.  
  525.   gc_scan_roots();                      /* Call gc_scan_range on each root   */
  526.  
  527.   /* Scan both allocation areas and copy the objects referenced */
  528.  
  529. Scan:
  530.  
  531. #ifdef DEBUG_GC
  532.   scanned_object  = 0;
  533.   if (sstate->debug)
  534.   { show_state();
  535.     os_warn( "[%d: SCANNING heap (no headers)]\n", SCM_obj_to_int(pstate->id) );
  536.   }
  537. #endif
  538.  
  539.   { long count = top_scan - top_alloc;  /* Scan objects without headers      */
  540.     gc_scan_range(top_alloc, count, (long)sizeof(SCM_obj));
  541.     top_scan -= count;
  542.   }
  543.  
  544. #ifdef DEBUG_GC
  545.   if (sstate->debug)
  546.   { show_state();
  547.     os_warn( "[%d: SCANNING heap (with headers)]\n", SCM_obj_to_int(pstate->id) );
  548.   }
  549. #endif
  550.  
  551.   while (bot_scan != bot_alloc)         /* Scan objects with headers         */
  552.   { long len, header = (long) *(bot_scan++);
  553.  
  554.     if (SCM_header_procedure(header))
  555.     { len = SCM_procedure_length( header );
  556. #ifdef DEBUG_GC
  557.       scanned_object = (long)bot_scan - sizeof(SCM_obj) + SCM_type_PROCEDURE;
  558. #endif
  559.       if (SCM_header_closure(header))
  560.         gc_scan_closure(bot_scan,header);
  561.     }
  562.     else
  563.     { len = SCM_header_length( header );
  564. #ifdef DEBUG_GC
  565.       scanned_object = (long)bot_scan - sizeof(SCM_obj) + SCM_type_SUBTYPED;
  566. #endif
  567.       if (SCM_subtype_is_ovector(SCM_header_subtype( header )))
  568.         gc_scan_range(bot_scan, SCM_header_slots(header), (long)sizeof(SCM_obj));
  569.       else if (SCM_header_subtype( header ) == SCM_subtype_WEAK_PAIR)
  570.         gc_scan_range(bot_scan+1, 1L, (long)sizeof(SCM_obj));  /* scan CDR only */
  571.     }
  572.  
  573.     bot_scan = (SCM_obj *)SCM_align(((char *)bot_scan) + len);
  574.   }
  575.  
  576.   if (top_scan != top_alloc) goto Scan; /* Scan newly copied objects         */
  577.  
  578.   *free_b = bot_alloc;
  579.   *free_t = top_alloc;
  580.  
  581.   barrier( "GC1" );
  582.  
  583.   /* Update all weak pairs */
  584.  
  585.   while (weak_pairs != NULL)
  586.   { SCM_obj car = weak_pairs[1];
  587.     SCM_obj *adr;
  588.     if ((car < const_bot) || (car >= const_top))
  589.       switch SCM_type(car)
  590.       { case SCM_type_PAIR:
  591.         case SCM_type_WEAK_PAIR:
  592.         case SCM_type_PLACEHOLDER:
  593.           adr = SCM_object_adr(car);
  594.           car = adr[0];
  595.           if (SCM_copied_no_header(car)) car = adr[1]; else car = SCM_false;
  596.           break;
  597.         case SCM_type_PROCEDURE:
  598.           adr = SCM_object_adr(car);
  599.          car = adr[0];
  600.           if (SCM_header_closure(car)) car = SCM_false;
  601.           break;
  602.         case SCM_type_SUBTYPED:
  603.           adr = SCM_object_adr(car);
  604.           car = adr[0];
  605.           if (!SCM_copied_header(car)) car = SCM_false;
  606.           break;
  607.         case SCM_type_FIXNUM:
  608.         case SCM_type_SPECIAL:
  609.           break;
  610.         default:
  611.           os_warn( "\nGC ERROR: Bad type code for CAR of WEAK_PAIR, CAR=0x%x", (long)car );
  612.           os_warn( " at 0x%x\n", (long)weak_pairs );
  613.           os_quit();
  614.       }
  615.     weak_pairs[1] = car;
  616.     weak_pairs = (SCM_obj *)weak_pairs[-1];
  617.   }
  618.  
  619. #ifdef DEBUG_GC
  620.   if (sstate->debug)
  621.     show_state();
  622. #endif
  623.  
  624.   barrier( "GC2" );
  625. }
  626.  
  627.  
  628. /*---------------------------------------------------------------------------*/
  629.